;;; -*- Mode:LISP; Package:SI; Base:10; Readtable:ZL -*-

;       ** (c) Copyright 1980 Massachusetts Institute of Technology **

(EVAL-WHEN (COMPILE LOAD EVAL)
  (FERROR NIL "If you are compiling or loading this, and not using RTC, you are losing!"))

;;;Negative codes:
;;; -1          quoted
;;; -2          eof
;;; -3          break
;;; -4          single
;;; -5          whitespace
;;; -6          macro
;;; -7          alphabetic
;;; -8          non-terminating macro
;;; -9          extended digit

;;;Bits
;;; 1           Whitespace (tested only in XR-XRTYI and XR-XRUNTYI)
;;; 2           slash (tested only in printing strings)
;;; 4           circle-cross (tested only in printing strings)
;;; 8           " String quote (tested only in printing strings)

(:MAC DIGIT '(// #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
      EXTENDED-DIGIT '(// -11)
      PLUS-MINUS '(// #/+ #/-)
      PLUS #/+
      POINT #/.
      BACKSLASH #/\
      SLASH #//
      VBAR #/|
      CIRCLECROSS #/
      EE '(// #/E #/e)
      SS '(// #/S #/s)
      DDLLFF '(// #/D #/d #/L #/l #/F #/f)
      EYE '(// #/i #/I)
      LSH-SCALE '(// #/_ #/^)
      EXTENSION-CHAR '(// #/^ #/_)
      SHARP-SIGN #/#
      COLON #/:
      NULL '(//)
      ;;Quoted chars to be mapped to -1.
      QUOTED-CHAR -1
      ;;EOF mapped to -2.
      EOF-CHAR -2
      ;;-5 is whitespace syntax
      WHITE-SPACE-CHAR '(// #/SP #/TAB #/LINE #/PAGE #/CR -5)
      ;;-3 is break syntax
      BREAK (NCONC '(// #/( #/) #/' #/` #/, #/" #/; #/ -2 -3 -4 -6)
                   (CDR WHITE-SPACE-CHAR))
      ;;-6 is macro syntax
      MACRO-CHARACTER '(// #/' #/, #/; #/` #/# #/( #/) #/" #/ -6 -8)
      ;;-8 is nonterminating macro syntax
      ;;-4 is single syntax
      STANDALONE-CHAR '(// -4)
      ;;-7 is alphabetic syntax
      ANY (CONS '// (DO ((I -11 (1+ I))
                         (X NIL (CONS I X)))
                        ((= I SI:RDTBL-ARRAY-SIZE) X)))
      ANY-BUT-EOF (DELETE -2 ANY)
      LETTER (LIST* '// -11 (DO ((I #/A (1+ I))
                                 (X NIL))
                                ((> I #/Z) X)
                              (PUSH I X)))

      PACKAGE-NAME '(* (- ANY-BUT-EOF (U COLON BREAK)))

      SIGN? '(:U NULL PLUS-MINUS)

      RTC-FIXNUM '(:! (:+ (:U DIGIT EXTENDED-DIGIT))
                     (:U NULL POINT)
                     (:U NULL
                         (:! LSH-SCALE
                             (:U NULL PLUS)
                             (:! (+ DIGIT)
                                 (:U NULL POINT))
                             (:U NULL POINT))))
      RTC-FLOAT-NO-EXP '(:! (:* DIGIT)
                            POINT
                            (:+ DIGIT))
      RTC-DECNUM '(:! (:+ DIGIT)
                      (:U NULL POINT))
      RTC-FLONUM '(:! (:U (:! RTC-FLOAT-NO-EXP
                              (:U NULL
                                  (:! EE
                                      SIGN?
                                      (:+ DIGIT))))
                          (:! RTC-DECNUM
                              EE
                              SIGN?
                              (:+ DIGIT))))
      RTC-SHORT-FLONUM '(:! (:U RTC-FLOAT-NO-EXP
                                RTC-DECNUM)
                            SS
                            SIGN?
                            (+ DIGIT))
      RTC-SINGLE-FLONUM '(:! (:U RTC-FLOAT-NO-EXP
                                 RTC-DECNUM)
                             DDLLFF
                             SIGN?
                             (:+ DIGIT))
      RTC-RATIONAL '(:! (:+ (:U DIGIT EXTENDED-DIGIT))
                        BACKSLASH
                        (:+ (:U DIGIT EXTENDED-DIGIT)))
      )

;;; A readtable definition looks like (:DEF name regular-expression type).
;;; "name" is the name of the kind of token.  It has a function to process the
;;;   string, on its property list, OR it is a symbol to be returned.
;;; "regular-expression" is a regular expression.
;;; "type" is a symbol indicating what to do with the last character
;;; recognized by the regular expression.

;;; First, numbers.  Anything that looks like a number really is one,
;;; so these can be first; and they must precede SYMBOL
;;; since all numbers would be symbols if they weren't numbers.
(:DEF FIXNUM
      (:! SIGN?
          RTC-FIXNUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF FLOAT
      (:! SIGN?
          RTC-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF SHORT-FLOAT
      (:! SIGN?
          RTC-SHORT-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF SINGLE-FLOAT
      (:! SIGN?
          RTC-SINGLE-FLONUM
          BREAK)
  UNTYI-FUNCTION)

(:DEF RATIONAL
      (:! SIGN?
          RTC-RATIONAL
          BREAK)
  UNTYI-FUNCTION)

(:DEF COMPLEX
      (:! SIGN?
          (:U (:! (:U RTC-FIXNUM
                      RTC-FLONUM
                      RTC-SHORT-FLONUM
                      RTC-SINGLE-FLONUM
                      RTC-RATIONAL)
                  PLUS-MINUS)
              SIGN?)
          (:U RTC-FIXNUM
              RTC-FLONUM
              RTC-SHORT-FLONUM
              RTC-SINGLE-FLONUM
              RTC-RATIONAL)
          EYE
          BREAK)
  UNTYI-FUNCTION)

(:DEF SHARP-PACKAGE-PREFIX
      (:! PACKAGE-NAME SHARP-SIGN COLON)
  LAST-CHAR)

(:DEF CONSING-DOT
      (:! POINT BREAK)
  UNTYI-QUOTE)

(:DEF EOF EOF-CHAR NO-UNTYI-QUOTE)

(:DEF MACRO-CHAR
      MACRO-CHARACTER
  LAST-CHAR)

(:DEF SC-SYMBOL
     STANDALONE-CHAR
  NO-UNTYI-FUNCTION)

(:DEF PACKAGE-PREFIX
     (:! PACKAGE-NAME COLON)
  LAST-CHAR)

;;; These are never reached, since slash and vbar are caught at a low level
;;; and only serve to quote other characters.  However,
;;; these do cause slash and vbar to have unique read syntaxes,
;;; which is how the low level checks for them.
(:DEF CHARACTER-CODE-ESCAPE CIRCLECROSS NO-UNTYI-FUNCTION)
(:DEF ESCAPE SLASH NO-UNTYI-FUNCTION)
(:DEF MULTIPLE-ESCAPE VBAR NO-UNTYI-FUNCTION)

;;; Must be last.
(:DEF SYMBOL
      (:! (:* (:- ANY-BUT-EOF BREAK))
          BREAK)
  UNTYI-FUNCTION)

(:OPT :WHITE-SPACE-CHAR (CDR WHITE-SPACE-CHAR))                 ;Options to RTC
(:OPT :MACRO-ALIST '((#/" XR-DOUBLEQUOTE-MACRO)
                     (#/( XR-OPENPAREN-MACRO)
                     (#/) XR-CLOSEPAREN-MACRO)
                     (#/' XR-QUOTE-MACRO)
                     (#/; XR-COMMENT-MACRO)
                     (#/` XR-BACKQUOTE-MACRO)
                     (#/, XR-COMMA-MACRO)
                     (#/# XR-DISPATCH-MACRO-DRIVER T
                      (#/' XR-#/'-MACRO)
                      (#/` XR-#/`-MACRO)
                      (#/ XR-#-MACRO)
                      (#/\ XR-#\-MACRO)
                      (#// XR-#\-MACRO)
                      (#/^ XR-#^-MACRO)
                      (#/, XR-#/,-MACRO)
                      (#/. XR-#.-MACRO)
                      (#/: XR-#/:-MACRO)
                      (#/= XR-#=-MACRO)
                      (#/# XR-##-MACRO)
                      (#/ XR-#-MACRO)
                      (#/( XR-#/(-MACRO)
                      (#/* XR-#*-MACRO)
                      (#/A XR-#A-MACRO)
                      (#/S XR-#S-MACRO)
                      (#/C XR-#C-MACRO)
                      (#/Q XR-#Q-MACRO)
                      (#/M XR-#M-MACRO)
                      (#/N XR-#N-MACRO)
                      (#/+ XR-#+-MACRO)
                      (#/- XR-#--MACRO)
                      (#/B XR-#B-MACRO)
                      (#/O XR-#O-MACRO)
                      (#/R XR-#R-MACRO)
                      (#/X XR-#X-MACRO)
                      (#/ INFIX-TOPLEVEL-PARSE)
                      (#/| XR-#/|-MACRO)
                      (#/! XR-#!-MACRO)
                      )))
(:OPT :READ-FUNCTION-PROPERTY 'STANDARD-READ-FUNCTION)
;; The next two are redundant.  They set different variables, but must match.
;(:OPT :QUOTE #//)
(:OPT :ESCAPE SLASH)
(:OPT :MULTIPLE-ESCAPE VBAR)
;; The next two are redundant.  They set different variables, but must match.
;(:OPT :CIRCLECROSS #/)
(:OPT :CHARACTER-CODE-ESCAPE CIRCLECROSS)
(:OPT :QUOTED-CHAR QUOTED-CHAR)
(:OPT :EOF-CHAR EOF-CHAR)
(:OPT :A-BREAK-CHAR -3)                                 ;For the reader to use.
(:OPT :MAKE-SYMBOL '(SC-SYMBOL))                        ;Who makes symbols
(:OPT :MAKE-SYMBOL-BUT-LAST '(SYMBOL))                  ;and how.
(:OPT :BITS '((#/" #o10)))                              ;Bits to be ored into readtable.
(:OPT SAVE-SYNTAX '(SINGLE -4                           ;Placed in plist of readtable
                    SLASH #//                           ; with syntax bits replacing
                    ESCAPE #//                          ; character numbers.
                    MULTIPLE-ESCAPE #/|
                    CHARACTER-CODE-ESCAPE #/
                    CIRCLECROSS #/
                    WHITESPACE -5
                    MACRO -6
                    NON-TERMINATING-MACRO -10
                    BREAK -3
                    ALPHABETIC -7
                    DIGITSCALE #/^
                    BITSCALE #/_
                    EXTENDED-DIGIT -11
                   ))
(:OPT :NAMES '("standard Zetalisp" "ZL" "T" "LM"
               "standard traditional syntax" "Traditional" "Zetalisp"))
(:OPT :PROPERTIES '(:SYNTAX :ZETALISP))
(:OPT :TRANSLATIONS '(((#/a  #/z)  (#/A  #/Z))))        ;Translations may be pairs of
                                                        ;intervals (inclusive) or just chars

(:END *READTABLE*)                                      ;The symbol whose value cell will
                                                        ;be loaded with the readtable
